home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 2: Applications / Linux Cubed Series 2 - Applications.iso / editors / emacs / xemacs / xemacs-1.004 / xemacs-1 / xemacs-19.13 / lisp / ilisp / lispworks.lisp < prev    next >
Encoding:
Text File  |  1995-01-26  |  3.4 KB  |  121 lines
  1. ;;; -*- Mode: Lisp -*-
  2.  
  3. ;;; lispworks.lisp --
  4.  
  5. ;;; This file is part of ILISP.
  6. ;;; Version: 5.7
  7. ;;;
  8. ;;; Copyright (C) 1990, 1991, 1992, 1993 Chris McConnell
  9. ;;;               1993, 1994 Ivan Vasquez
  10. ;;;               1994, 1995 Marco Antoniotti and Rick Busdiecker
  11. ;;;
  12. ;;; Other authors' names for which this Copyright notice also holds
  13. ;;; may appear later in this file.
  14. ;;;
  15. ;;; Send mail to 'ilisp-request@lehman.com' to be included in the
  16. ;;; ILISP mailing list. 'ilisp@lehman.com' is the general ILISP
  17. ;;; mailing list were bugs and improvements are discussed.
  18. ;;;
  19. ;;; ILISP is freely redistributable under the terms found in the file
  20. ;;; COPYING.
  21.  
  22.  
  23.  
  24. ;;; LispWorks ILISP initializations.
  25. ;;;
  26. ;;; Independently written by:
  27. ;;;
  28. ;;; Jason Trenouth: jason@harlequin.co.uk
  29. ;;; Qiegang Long: qlong@cs.umass.edu
  30. ;;;
  31. ;;; and later merged together by Jason
  32.  
  33.  
  34. (in-package "ILISP")
  35.  
  36. (defun ilisp-callers (symbol package)
  37.   "Print a list of all of the functions that call FUNCTION.
  38. Return T if successful."
  39.   (ilisp-errors
  40.       (let ((function-name (ilisp-find-symbol symbol package))
  41.         (*print-level* nil)
  42.         (*print-length* nil)
  43.         (*package* (find-package 'lisp))
  44.         (callers ())
  45.         )
  46.     (when (and function-name (fboundp function-name))
  47.       (setf callers (munge-who-calls (lw:who-calls function-name)))
  48.       (dolist (caller callers)
  49.         (print caller))
  50.       t))))
  51.       
  52. ;; gross hack to munge who-calls output for ILISP
  53. (defun munge-who-calls (who-calls)
  54.   (labels ((top-level-caller (form)
  55.          (if (atom form)
  56.          form
  57.          (top-level-caller (second form)))))
  58.     (delete-if-not 'symbolp
  59.            (delete-duplicates (mapcar #'top-level-caller who-calls)))))
  60.  
  61.  
  62. ;; Jason 6 SEP 94 -- tabularized Qiegang's code
  63. ;;
  64. ;; There are some problems lurking here:
  65. ;;   - the mapping ought to be done by LispWorks
  66. ;;   - surely you really want just three source types:
  67. ;;     function, type, and variable
  68. ;;
  69. (defconstant *source-type-translations*
  70.   '(
  71.     ("class"     defclass)
  72.     ("function"  )
  73.     ("macro"     )
  74.     ("structure" defstruct)
  75.     ("setf"      defsetf)
  76.     ("type"      deftype)
  77.     ("variable"  defvar defparameter defconstant)
  78.     ))
  79.  
  80.  
  81. (defun translate-source-type-to-dspec (symbol type)
  82.   (let ((entry (find type *source-type-translations*
  83.              :key 'first :test 'equal)))
  84.     (if entry
  85.     (let ((wrappers (rest entry)))
  86.       (if wrappers
  87.           (loop for wrap in wrappers collecting `(,wrap ,symbol))
  88.           `(,symbol)))
  89.     (error "unknown source type for ~S requested from ILISP: ~S"
  90.            symbol type))))
  91.  
  92.  
  93. (defun ilisp-source-files (symbol package type)
  94.   "Print each file for PACKAGE:SYMBOL's TYPE definition on a line and
  95. return T if successful.  A function to limit the search with type?"
  96.   (ilisp-errors
  97.    (let* ((symbol (ilisp-find-symbol symbol package))
  98.       (all (equal type "any"))
  99.       (paths (when symbol (compiler::find-source-file symbol)))
  100.       (dspecs (or all (translate-source-type-to-dspec symbol type)))
  101.       (cands ())
  102.       )
  103.      (if (and paths (not all))
  104.      (setq cands
  105.            (loop for path in paths
  106.              when (find (car path) dspecs :test 'equal)
  107.              collect path))
  108.        (setq cands paths))
  109.      (if cands
  110.      (progn
  111.        (dolist (file (remove-duplicates paths
  112.                         :key #'cdr :test #'equal))
  113.          (print (namestring (cadr file))))
  114.        t)
  115.      nil))))
  116.  
  117. (unless (compiled-function-p #'ilisp-callers)
  118.   (format t "\"ILISP: File is not compiled, use M-x ilisp-compile-inits\""))
  119.  
  120. ;;; end of file -- lispworks.lisp --
  121.